// XMLLib version 1
//
// Author
//
//   Thomas Koos (info@muetze1.de)
//   www.muetze1.de
//
// License
//
//   This Source Code Form is subject to the terms of the Mozilla Public
//   License, v. 1.1. If a copy of the MPL was not distributed with this
//   file, You can obtain one at http://mozilla.org/MPL/1.1/.
//
// Description
//
//   String adapter class used by the XML library to uniformly access
//   any string adapter registered in the library.
//
// Revision
//
//  $Id: StrAdapter.pas 18 2014-04-21 21:28:10Z muetze1@gmail.com $
//

Unit StrAdapter;

Interface

{$Z+}  // equal to $Z4 on newer compilers

Uses
  StrAdapterBase,      // for TBaseStringAdapter
  StrAdapterOptions,   // for TStringAdapterOptions
  Classes,             // for TStrings
  SysUtils;            // for Exception

Type
    // base exception class for all string adapter exceptions
  EStringAdapterException = Class(Exception);

    // String Adapter exception thrown on unknown string encoding types.
    //
    // Most common cause for this exception is the missing of the
    // string coding units (e.g. StrAdapterISO8859_1.pas) in the project
    // file. All string adapter units support an special charset coding
    // and will register with the help of the initialization part of the unit.
    // The initialization part is only executed if the unit is used or included
    // in the project file.
  ESAWrongEncodingException = Class(EStringAdapterException);

    // String Adapter exception thrown on illegal char for current encoding type.
    //
    // This exception is mostly thrown, if your xml file has no charset encoding
    // instruction and uses local specific characters. The library uses
    // the UTF-8 coding, if no charset encoding is given in the xml header. To prevent
    // this exception and copy the illegal character simply to the data, set the
    // IgnoreIllegalCharacter in the xmllib coding options to true.
  ESAIllegalCharacterException = Class(EStringAdapterException);

type
    // Class for managing all string adapters and offering access to different adapters
    // and codings.
  TStringAdapter = Class
  Private
    Procedure SetEncoding(Const Value: String);
    procedure SetOptions(const Value: TStringAdapterOptions);

  Protected
    fEncoding: String;
    fOptions: TStringAdapterOptions;
    fEncoder: TBaseStringAdapter;

    function SelectStringAdapter(const aEncoding: string; const aOptions: TStringAdapterOptions): TBaseStringAdapter;

    function DecodeEntities(AInput: string): string; dynamic;
    function EncodeEntities(AInput: string; const ADataType: TStringDataType): string; dynamic;

  Public
    Constructor Create(Const AEncoding: String; Const AOptions: TStringAdapterOptions);
    Destructor Destroy; Override;

    Class Procedure RegisterAdapter(AdapterClass: TStringAdapterMetaClass);
    Class Procedure GetRegisteredAdapters(Const AList: TStrings);
    Class Function IsCodingAvailable(Const ACodingID: String): Boolean;

    function StringDecode(Const ACodedString: AnsiString; const ADataType: TStringDataType): String; virtual;
    function StringEncode(Const AEncodedString: String; const ADataType: TStringDataType): AnsiString; virtual;

      // This property offers the actual encoding identifier and the possibility to change
      // it by assigning a new identifier to it. If the newly assigned encoding can not be found
      // an ESAWrongEncodingException exception is raised.
      //
      // Exceptions
      //   ESAWrongEncodingException
    property EncodingID: String read fEncoding write SetEncoding;

      // This property offers the options for the string adapter. For more information see
      // TStringAdapterOptions.
      //
      // See Also
      //   TStringAdapterOptions
    property Options: TStringAdapterOptions read fOptions write SetOptions;
  end;

{$UNDEF ImplementAnsiSameText}

{$IFDEF VER120}
{$DEFINE ImplementAnsiSameText}
{$ENDIF}

{$IFDEF VER125}
{$DEFINE ImplementAnsiSameText}
{$ENDIF}

{$IFDEF ImplementAnsiSameText}
function AnsiSameText(const AStr1, AStr2: string): boolean;
procedure FreeAndNil(var AObject);
{$ENDIF}

implementation

{$DEFINE ImplementIfThen}

{$IFNDEF FPC}
{$IFNDEF VER120}
{$IFNDEF VER125}
{$IFNDEF VER130}
{$IFNDEF VER140}
{$IF RTLVersion >= 15.0}
uses
  Math;               // for IfThen()
{$UNDEF ImplementIfThen}
{$IFEND}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}

{$IFDEF ImplementAnsiSameText}
  // just for Delphi 4/C++Builder 4
function AnsiSameText(const AStr1, AStr2: string): boolean;
begin
  result := AnsiCompareText(AStr1, AStr2) = 0;
end;

procedure FreeAndNil(var AObject);
var
  lObject: TObject;
begin
  lObject := TObject(AObject);
  pointer(AObject) := nil;
  lObject.Free;
end;
{$ENDIF}

var
    // array containing all registered string adapters
  StrAdapters: array of TStringAdapterMetaClass;

{ TStringAdapter }

  // Constructor of the TStringAdapter. The passed encoding is the default or start encoding
  // and can be changed later by accessing the EncodingID property of the class.
  //
  // Parameters
  //   AEncoding      - Default or start encoding. This parameter can be changed later by
  //                    accessing the EncodingID property of the instance.
  //   AOptions       - Instance of the options class for the string adapters. This parameter
  //                    can be <b>nil</b>.   
  //
  // Exceptions
  //   ESAWrongEncodingException
constructor TStringAdapter.Create(const AEncoding: String; const AOptions: TStringAdapterOptions);
begin
  inherited Create;

  fEncoding := AEncoding;
  fOptions := AOptions;
  fEncoder := SelectStringAdapter(fEncoding, fOptions);

  if not Assigned(fEncoder) then
    raise ESAWrongEncodingException.CreateFmt('unknown encoding type ("%s")!', [fEncoding]);
end;

function TStringAdapter.DecodeEntities(AInput: string): string;
const
  coMaxEntityLength = 10;
var
  lSource, lTemp, lDestPtr, lDestOrg: PChar;
  lCode: integer;
  lDest, lCodeStr: string;
  lHex: boolean;

{$IFDEF ImplementIfThen}
  function IfThen(const ACond: boolean; const ATrueValue: Integer; const AFalseValue: Integer = 0): integer;
  begin
    if ACond then
      result := ATrueValue
    else
      result := AFalseValue;
  end;
{$ENDIF}

begin
  SetLength(lDest, length(AInput));
  lSource := PChar(AInput);
  lDestOrg := PChar(lDest);
  lDestPtr := lDestOrg;

  while ( ord(lSource^) <> 0 ) do
  begin
    if ( lSource^ = '&' ) then
    begin
      Inc(lSource);  // &

      if lSource^ = '#' then
      begin
        Inc(lSource);  // #
        lTemp := lSource;
        //Inc(lTemp);

        lHex := ( lTemp^ = 'x' );

        if lHex then
          Inc(lTemp);

        while ( lTemp^ >= '0' ) and ( lTemp^ <= '9' ) do
          Inc(lTemp);

        if ( lTemp - lSource > IfThen(lHex, 1) ) and ( lTemp^ = ';' ) then
        begin
          if lHex then
            Inc(lSource);

          SetString(lCodeStr, lSource, lTemp - lSource);

          if lHex then
            lCodeStr := HexDisplayPrefix + lCodeStr;

          lCode := StrToInt(lCodeStr);

          if not fEncoder.DecodeEntity(lDestPtr, lCode) then
          begin
              // copy the entity without any convertion
            lDestPtr^ := '&';
            Inc(lDestPtr);
            if lHex then
              Delete(lCodeStr, 1, length(HexDisplayPrefix));
            StrPCopy(lDestPtr, lCodeStr);
            Inc(lDestPtr, length(lCodeStr));
            lDestPtr^ := ';';
            Inc(lDestPtr);
          end;

          Inc(lSource, lTemp-lSource+1);
          if lHex then
            Inc(lSource);

          Continue;
        end;
      end
      else
      begin
        lTemp := lSource;

        while ( lTemp^ <> ';' ) and ( ord(lTemp^) <> 0 ) do
        begin
          Inc(lTemp);

          if lTemp - lSource > coMaxEntityLength then
            break;
        end;

        if lTemp^ = ';' then
        begin
          SetString(lCodeStr, lSource, lTemp - lSource);

          if not fEncoder.DecodeEntity(lDestPtr, lCodeStr) then
          begin
              // copy the entity without any convertion
            lDestPtr^ := '&';
            Inc(lDestPtr);
            StrPCopy(lDestPtr, lCodeStr);
            Inc(lDestPtr, length(lCodeStr));
            lDestPtr^ := ';';
            Inc(lDestPtr);
            Inc(lSource, length(lCodeStr)+1);
          end
          else
          begin
            Inc(lSource, length(lCodeStr)+1);
            continue;
          end;
        end
        else
        begin
          lDestPtr^ := '&';
          Inc(lDestPtr);
        end;
      end;
    end;

    lDestPtr^ := lSource^;

    Inc(lSource);
    Inc(lDestPtr);
  end;

  SetString(result, lDestOrg, lDestPtr - lDestOrg);
end;

  // destructor of the TStringAdapter. Nothing special...
destructor TStringAdapter.Destroy;
begin
  fEncoder.Free;

  inherited;
end;

function TStringAdapter.EncodeEntities(AInput: string; const ADataType: TStringDataType): string;
var
  lCode: integer;
  lSource: PChar;
  lDest, lCoded: String;
begin
  lSource := PChar(AInput);
  lDest := '';

  while ord(lSource^) <> 0 do
  begin
    lCode := ord(lSource^);
    lCoded := '';

    if ( ( ( lCode < 32 ) or ( lCode > 128 ) ) and
         ( ( fOptions.ExcludeApostroph and ( lSource^ <> '''' ) )
           or not fOptions.ExcludeApostroph ) )
        or // standard entities
        fEncoder.EncodeEntity(lCoded, lCode, saecNamed) then
    begin
      if (aDataType = sdtCDATA) or
         (fOptions.EntityCoding = saecDisabled) or
         not fEncoder.EncodeEntity(lCoded, lCode, fOptions.EntityCoding) or
         ( fOptions.ExcludeApostroph and ( lSource^ = '''' ) ) or
         ( lCoded = '' ) then
      begin
        lDest := lDest + lSource^;
      end
      else
        lDest := lDest + lCoded;
    end
    else
      lDest := lDest + lSource^;

    Inc(lSource);
  end;

  result := lDest;
end;

  // This class method returns all registered string adapters in the passed list.
  // This function can be used to offer an possibility for the user to select the wanted
  // charset coding for the XML file.
  //
  // Parameters
  //   AList     - The list where the known string codings should be filled in. If
  //               the passed list is <b>nil</b>, the function does nothing.
class procedure TStringAdapter.GetRegisteredAdapters(const AList: TStrings);
var
  i : Integer;
begin
  if Assigned(AList) then
  begin
    AList.BeginUpdate;
    try
      for i := Low(StrAdapters) to High(StrAdapters) do
        AList.Append(StrAdapters[i].EncodingID);
    finally
      AList.EndUpdate;
    end;
  end;
end;

  // Class method for testing the availability for the specified charset coding.
  //
  // Parameters
  //   ACodingID     - The charset coding to check
  //
  // Returns
  //   The function returns true if the charset coding is available or false. 
Class Function TStringAdapter.IsCodingAvailable(Const ACodingID: String): Boolean;
Var
  i : Integer;
Begin
  Result := False;

  For i := Low(StrAdapters) To High(StrAdapters) Do
  begin
    If AnsiSameText(StrAdapters[i].EncodingID, ACodingID) Then
    Begin
      Result := True;
      Break;
    End;
  end;
End;

  // This class method is used to register string adapters so they are known and can
  // be instanced on demand. If the string adapter class is already registered, the
  // function does nothing.
  //
  // Parameters
  //   AdapterClass     - string adapter class to register
Class Procedure TStringAdapter.RegisterAdapter(AdapterClass: TStringAdapterMetaClass);
Var
  i : Integer;
Begin
    // already registered?
  For i := Low(StrAdapters) To High(StrAdapters) Do
    If ( StrAdapters[i] = AdapterClass ) Then
      Exit;

  SetLength(StrAdapters, Length(StrAdapters)+1);
  StrAdapters[High(StrAdapters)] := AdapterClass;
End;

function TStringAdapter.SelectStringAdapter(const aEncoding: string; const aOptions: TStringAdapterOptions): TBaseStringAdapter;
var
  i: Integer;
begin
  for i := Low(StrAdapters) to High(StrAdapters) do
  begin
    if AnsiSameText(StrAdapters[i].EncodingID, aEncoding) then
    begin
      result := StrAdapters[i].Create(aOptions);
      exit;
    end;
  end;

    // If you receive this error and the file has UTF-8, ISO8859-1 or Windows-1252 coding, please ensure that you
    // included the StrAdapterISO8859_1, StrAdapterUTF_8 and/or StrAdapterWindows1252 in your project management!
    // The String Adapter will only register, if they are used/included in the project!
    //
    // When using this library under CodeGear/Borland C++ Builder you have to add
    // <code>#pragma link "StrAdapterUTF_8"
    // #pragma link "StrAdapterISO8859_1"
    // #pragma link "StrAdapterWindows1252"</code>
    // to get the string adapters linked in.
  raise ESAWrongEncodingException.CreateFmt('Requested encoding type is unknown/unsupported (%s)!', [aEncoding]);
end;

Procedure TStringAdapter.SetEncoding(const Value: String);
Begin
    // FreeAndNil() is required, because SelectStringAdapter can throw an ESAWrongEncodingException exception
    // without creating an new instance - so fEncoder will be freed but pointing to the holy data space nirvana...
  FreeAndNil(fEncoder);

  fEncoder := SelectStringAdapter(Trim(Value), fOptions);
  fEncoding := Value;
End;

procedure TStringAdapter.SetOptions(const Value: TStringAdapterOptions);
begin
  if ( fOptions = nil ) and ( Value <> nil ) then
  begin
    fOptions := Value;
    fEncoder.Options := Value;
  end;
end;

  // This function calls the StringDecode() function of the actually selected string
  // adapter to decode the passed string.
  //
  // Parameters
  //   ACodedString          - The coded string to decode
  //   AOptions              - This optional parameter defines the handling of entities
  //                           (e.g. &quot;, &#33;).
  //
  // Returns
  //   The decoded string or the passed string if no encoder is currently selected. 
function TStringAdapter.StringDecode(const ACodedString: AnsiString; const ADataType: TStringDataType): string;
var
  lData: string;
begin
  if assigned(fEncoder) then
    lData := fEncoder.Decode(ACodedString)
  else
    lData := string(ACodedString);

  result := DecodeEntities(lData);
end;

  // This function calls the StringEncode() function of the actually selected string
  // adapter to encode the passed string.
  //
  // Parameters
  //   AEncodedString        - The decoded string to encode
  //   ADataType             - Defines the type of data in the string
  //                           (e.g. sdtNodeValue).
  //
  // Returns
  //   The encoded string or the passed string if no encoder is currently selected.
Function TStringAdapter.StringEncode(Const AEncodedString: String; const ADataType: TStringDataType): AnsiString;
Var
  lData: String;
begin
  lData := EncodeEntities(AEncodedString, aDataType);

  If Assigned(fEncoder) Then
    Result := fEncoder.Encode(lData)
  Else
    Result := AnsiString(lData);
End;

End.




